{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
--
-- Module      :  LLVM.Code.Instructions.Memory
-- Copyright   :  Mikhail Belyaev
-- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module LLVM.Code.Instructions.Memory where


import LLVM.Parser.Record.Record (recordAsList)
import LLVM.Parser.Record.Record
       (getCode, recordAsHeadlessList, RecordType(..))
import LLVM.Code.Shared (ValIndex(..))
import LLVM.Code.Shared (cmpFromInteger, TypeIndex(..))

import LLVM.Util
import LLVM.Code.Types
       (getIndexOfType, Type(..), Type, getTypeByIndex)
import LLVM.Code.Instructions.Class (BuildableInstruction(..))
import LLVM.Code.Instructions.Util
       (Matched(..), Matcher(..), matchRRwithCode)
import LLVM.Code.Instructions.Values
       (StoreInstruction(..), LoadInstruction(..), FreeInstruction(..),
        AllocaInstruction(..), MallocInstruction(..))




instance BuildableInstruction MallocInstruction where -- MALLOC is 17
        buildInstruction (recordAsHeadlessList -> (17:tail)) tt vt =
                let typed t = tt `getTypeByIndex` TypeIndex t
                    value t = ValIndex t
                in
                case (tail) of
                     ((typed -> Just ty):(value -> v):al:_) ->
                            Just MallocInstruction{
                                mallocType = ty,
                                mallocOp = v,
                                mallocAlign = al
                            }
                     _ -> Nothing
        buildInstruction _ _ _ = Nothing



instance BuildableInstruction AllocaInstruction where -- ALLOCA is 19
        buildInstruction (recordAsHeadlessList -> (19:tail)) tt vt =
                let typed t = tt `getTypeByIndex` TypeIndex t
                    value t = ValIndex t
                in
                case (tail) of
                     ((typed -> Just ty):(typed -> Just opty):(value -> v):al:_) ->
                            Just AllocaInstruction{
                                allocaType = ty,
                                allocaOpType = opty,
                                allocaOp = v,
                                allocaAlign = al
                            }
                     ((typed -> Just ty):(value -> v):al:_) ->
                            Just AllocaInstruction{
                                allocaType = ty,
                                allocaOpType = LLInt 32,
                                allocaOp = v,
                                allocaAlign = al
                            }
                     _ -> Nothing
        buildInstruction _ _ _ = Nothing




instance BuildableInstruction FreeInstruction where
    buildInstruction rr tt vt =
        case (matchRRwithCode tt vt [MValueTypePair] 18 rr) of
             [MdValueTypePair (v,ty)] ->
                    Just FreeInstruction{
                        freeType = ty,
                        freeValue = v
                    }
             _ -> Nothing



instance BuildableInstruction LoadInstruction where
    buildInstruction rr tt vt =
        case (matchRRwithCode tt vt [MValueTypePair, MInteger, MInteger] 20 rr) of
             [MdValueTypePair (v,ty), MdInteger al, MdInteger ((/= 0)-> vol)] ->
                    Just LoadInstruction{
                        loadPtType = ty,
                        loadPtr = v,
                        loadAlign = al,
                        loadIsVolatile = vol
                    }
             _ -> Nothing



instance BuildableInstruction StoreInstruction where
    buildInstruction rr@(getCode -> Just 24) tt vt = -- the new store (STORE2)
        case (matchRRwithCode tt vt [MValueTypePair, MValue, MInteger, MInteger] 24 rr) of
             [MdValueTypePair (ptr,ptrty), MdValue val, MdInteger al, MdInteger ((/= 0)-> vol)] ->
                    Just StoreInstruction{
                        storePtType = ptrty,
                        storePtr = ptr,
                        storeVal = val,
                        storeAlign = al,
                        storeIsVolatile = vol
                    }
             _ -> Nothing
    buildInstruction rr@(getCode -> Just 20) tt vt = -- the old store (STORE)
        case (matchRRwithCode tt vt [MValueTypePair, MValue, MInteger, MInteger] 20 rr) of
             [MdValueTypePair (val,(getIndexOfType tt -> Just valti)),
                MdValue ptr, MdInteger al, MdInteger ((/= 0)-> vol)] ->
                    Just StoreInstruction{
                        storePtType = LLPointer valti 0, -- ptrty is ptr to valty
                        storePtr = ptr,
                        storeVal = val,
                        storeAlign = al,
                        storeIsVolatile = vol
                    }
             _ -> Nothing

    buildInstruction _ _ _ = Nothing
